Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/Finger 1.3.5/source/Finger/Fingers.p

Text File | 1992-02-24 | 19.8 KB | 833 lines | [TEXT/PJMM]

unit Fingers;

{ This code is part of the Finger/Fingerd source code, written in THINK Pascal 4 }
{ Copyright 1991-1992 Peter N Lewis }
{ If you use this code, you must give me credit in your about box and documentation }

interface

    uses
        OOMainLoop;

    const
        WT_FingerOutput = 'FOut';

    type
        DefObject = object(DObject)
                procedure CalculateRegion (var rgn: rgnHandle);
                override;
                function DoMainClick (er: eventRecord): boolean;
                override;
            end;

    var
        giveOoMerror: boolean;   { Enable out of mem error every time a menu is chosen }
        has_MacTCP11: boolean;

    procedure InitFingers;
    procedure FinishFingers;
    procedure HandleFingerTCPEvents;
    procedure Finger;
    procedure DoFingerCommand (s: str255);
    procedure FailAlert (s: str255; n: longInt);
    function IsFingerWindow (wp: windowPtr): boolean;
    function GetFingerTE (wp: windowPtr): TEHandle;

implementation

    uses
        MyUtilities, MyFileSystem, AppGlobals, Preferences, MyTranslate82728, {}
        TCPTypes, TCPStuff, TCPConnections, OOStaticEdit, {}
        FingerDaemon, MyInternetMenu, MyAddressInput, MyGrowZones;

    const
        my_waiting_cursor = 128;

    type
        FIObject = object(AIObject)
                procedure Create (id: integer);
                override;
                procedure DoItem (item: integer);
                override;
                procedure DoKey (modifiers: integer; ch: char; code: integer);
                override;
                procedure PackStringBlank (var s: str255);
                override;
                procedure PackString (var s: str255);
                override;
                procedure UnPackString (s: str255);
                override;
                function IsOKOn: boolean;
                override;
                function IsSetDefaultOn: boolean;
                override;
                procedure DoCommand (s: str255);
                override;
                procedure GetDialog;
                override;
            end;
        FOObject = object(DObject)
                textob: TEStaticObject;
                connection: ConnectionIndex;
                datahandle: handle;
                procedure Create (id: integer);
                override;
                procedure Destroy;
                override;
                procedure Resize;
                override;
                function EditMenuEnabled: boolean;
                override;
                procedure SetEditMenuItem (item: integer);
                override;
                procedure DoEditMenu (item: integer);
                override;
                procedure Zoom (code: integer);
                override;
                function DoMainClick (er: eventRecord): boolean;
                override;
                procedure DoItemWhere (er: eventRecord; item: integer);
                override;
                procedure DoActivateDeactivate (activate: boolean);
                override;
                procedure CalculateRegion (var rgn: rgnHandle);
                override;
            end;

    const
        finger_input_refcon = -1;
        fi_port = 7;
        fo_text_item = 1;
        ports_strh_id = 300;
        finger_str_index = 1;
        finger_port_index = 2;
        whois_str_index = 3;
        whois_port_index = 4;
        general_strh_id = 400;
        cmd_key_index = 2;
        finger_button_index = 3;
        whois_button_index = 4;
        daemons_max = 10;

    var
        max_daemons: integer;
        fingerd: array[1..daemons_max] of connectionIndex;
        fingerdata: array[1..daemons_max] of handle;
        default_whois: boolean;
        fingering: integer;
        trans: transTable;
        finger_port, whois_port, fingerd_port: integer;
        whois_str: str63;
        max_sane_handle_size: longInt;
        cmd_key: char;
        finger_button_str, whois_button_str: string[10];

    procedure FailAlert (s: str255; n: longInt);
        var
            s2: str255;
            a: integer;
    begin
        if n = 0 then
            s2 := ''
        else
            NumToString(n, s2);
        Paramtext(s, s2, '', '');
        a := Alert(fail_alert_id, nil);
    end;

    procedure PackName (var s: str255; name, mach: str255; whois: boolean);
        function hasat (n: str255): boolean;
            var
                i: integer;
        begin
            hasat := Pos('@', n) > 0;
        end;

        procedure Validate (n: str255);
            var
                i: integer;
        begin
            s := n;
            if s[length(s)] = '@' then
                s := '?';
            i := 1;
            while i < length(s) do begin
                if (s[i] = '@') and (s[i + 1] = '@') then
                    s := '?';
                i := i + 1;
            end;
            if Pos(concat(':', whois_str), s) <> 0 then
                s := '?';
        end;
    begin
        s := '?';
        if hasat(name) then begin
            if mach = '' then
                Validate(name);
        end
        else if hasat(mach) then begin
            if name = '' then
                Validate(mach);
        end
        else begin
            Validate(concat(name, '@', mach));
        end;
        if (s <> '?') and whois then
            s := concat(s, ':', whois_str);
    end;

    procedure UnpackName (s: str255; var name, mach: str255; var whois: boolean);
        var
            p: integer;
    begin
        p := length(s);
        while s[p] <> '@' do
            p := p - 1;
        name := copy(s, 1, p - 1);
        mach := copy(s, p + 1, 255);
        p := Pos(concat(':', whois_str), mach);
        whois := p > 0;
        if whois then
            mach := copy(mach, 1, p - 1);
    end;

    function IsFingerWindow (wp: windowPtr): boolean;
    begin
        IsFingerWindow := GetWType(wp) = WT_FingerOutput;
    end;

    function GetFingerTE (wp: windowPtr): TEHandle;
    begin
        GetFingerTE := FOObject(GetWObject(wp)).textob.te;
    end;

    procedure FIObject.PackStringBlank (var s: str255);
    begin
        if (default_machine = '') and (default_user = '') then
            if default_whois then
                s := concat('@:', whois_str) {sleeze}
            else
                s := '@'
        else
            PackName(s, default_user, default_machine, default_whois);
    end;

    procedure FIObject.PackString (var s: str255);
    begin
        PackName(s, default_user, default_machine, default_whois);
    end;

    procedure FIObject.UnPackString (s: str255);
    begin
        UnPackName(s, default_user, default_machine, default_whois);
    end;

    function FIObject.IsOKOn: boolean;
        var
            s, s1, s2: str255;
    begin
        GetItemText(window, ai_user, s1);
        GetItemText(window, ai_machine, s2);
        PackName(s, s1, s2, false);
        IsOkOn := s <> '?';
    end;

    function FIObject.IsSetDefaultOn: boolean;
        var
            s, s1, s2: str255;
    begin
        GetItemText(window, ai_user, s1);
        GetItemText(window, ai_machine, s2);
        PackName(s, s1, s2, false);
        IsSetDefaultOn := (s <> '?') or ((s1 = '') and (s2 = ''));
    end;

    procedure FIObject.GetDialog;
        var
            kind: integer;
            h: handle;
            r: rect;
    begin
        inherited GetDialog;
        GetDItem(window, fi_port, kind, h, r);
        default_whois := GetCtlValue(controlhandle(h)) <> 0;
    end;

    procedure TogglePort (wp: windowPtr);
        var
            kind: integer;
            h: controlHandle;
            r: rect;
            cv: integer;
    begin
        GetDItem(wp, fi_port, kind, handle(h), r);
        cv := 1 - GetCtlValue(h);
        SetCtlValue(h, cv);
        GetDItem(wp, ai_ok, kind, handle(h), r);
        if cv = 0 then {finger}
            SetCTitle(h, finger_button_str)
        else
            SetCTitle(h, whois_button_str);
    end;

    procedure FIObject.Create (id: integer);
        var
            kind: integer;
            h: handle;
            r: rect;
    begin
        inherited Create(id);
        GetDItem(window, fi_port, kind, h, r);
        SetCtlValue(controlhandle(h), ord(default_whois));
        TogglePort(window); { Set up Finger/Whois button }
        TogglePort(window);
        ShowWindow(window);
    end;

    procedure DoFingerCommand (s: str255);
        var
            cp: connectionIndex;
            oe: OSErr;
            s1, s2: str255;
            whois: boolean;
            sh: stringHandle;
    begin
        UnpackName(s, s1, s2, whois);
        sh := NewString(s);
        oe := FindAddress(cp, s2, sh);
        if oe <> noErr then begin
            FailAlert('FindAddress failed with error ', oe);
            DisposHandle(handle(sh));
        end
        else
            fingering := fingering + 1;
    end;

    procedure FIObject.DoCommand (s: str255);
    begin
        DoFingerCommand(s);
    end;

    procedure FIObject.DoItem (item: integer);
    begin
        case item of
            fi_port:
                TogglePort(window);
            otherwise
                inherited DoItem(item);
        end;
    end;

    procedure FIObject.DoKey (modifiers: integer; ch: char; code: integer);
    begin
        if (BAND(modifiers, cmdKey) <> 0) and (IUEqualString(ch, cmd_key) = 0) then
            TogglePort(window);
        inherited DoKey(modifiers, ch, code);
    end;

    procedure FailOutOfMemory;
    begin
        if giveOoMerror then begin
            FailAlert('I have run out of Memory.  Give me some more!', 0);
            giveOoMerror := false;
        end;
    end;

    function ReadChars (tcpc: TCPConnectionPtr; h: handle; count: longInt; striplf: boolean; important: boolean): boolean;
{ return true if out of memory }
        var
            size, i, j: longInt;
            b: signedByte;
            p: ptr;
            oe: OSErr;
    begin
        ReadChars := false;
        if not important and MemoryCritical then begin
            FailOutOfMemory;
            oe := TCPFlush(tcpc);
            ReadChars := true;
            Exit(ReadChars);
        end;
        size := GetHandleSize(h);
        if size + count > max_sane_handle_size then
            count := max_sane_handle_size - size;
        if count > 0 then begin
            SetHandleSize(h, size + count);
            if GetHandleSize(h) <> size + count then begin
                FailOutOfMemory;
                oe := TCPFlush(tcpc);
                ReadChars := true;
                Exit(ReadChars);
            end
            else begin
                HLock(h);
                oe := TCPReceiveChars(tcpc, ptr(longInt(h^) + size), count);
                j := size;
                if oe = noErr then begin
                    if striplf then begin
                        for i := size to size + count - 1 do begin
                            b := ptr(longInt(h^) + i)^;
                            case b of
                                10:  begin
                                    p := ptr(longInt(h^) + j);
                                    p^ := trans[13];
                                    j := j + 1;
                                end;
                                13:
                                    ;
                                otherwise begin
                                    p := ptr(longInt(h^) + j);
                                    p^ := trans[BAND(b, $FF)];
                                    j := j + 1;
                                end;
                            end;
                        end;
                    end
                    else
                        j := size + count;
                end;
                HUnlock(h);
                if j <> size + count then
                    SetHandleSize(h, j);
            end;
        end
        else
            oe := TCPFlush(tcpc);
    end;

    function StripCRLF (h: handle): boolean;
        var
            size, i: longInt;
            b: signedByte;
    begin
        StripCRLF := false;
        size := GetHandleSize(h);
        for i := 0 to size - 1 do begin
            b := ptr(longInt(h^) + i)^;
            if (b = 13) or (b = 10) then begin
                StripCRLF := true;
                SetHandleSize(h, i);
                leave;
            end;
        end;
    end;

{$ Init}
    procedure InitFingers;
        var
            th: handle;
            i: integer;
            s: str255;
            temp: longInt;
        procedure GetIndNumber (id, index: integer; var num: integer);
            var
                temp: longInt;
        begin
            GetIndString(s, id, index);
            StringToNum(s, temp);
{$PUSH}
{$R-}
            num := temp;
{$R-}
        end;
    begin
        if has_MacTCP11 then begin
            GetIndNumber(fingerd_strh, daemons_max_index, max_daemons);
            if max_daemons > daemons_max then
                max_daemons := daemons_max;
        end
        else
            max_daemons := 1;
        for i := 1 to max_daemons do
            fingerd[i] := no_connection;
        fingering := 0;
        GetTrans(translateInResID, trans);
        GetIndNumber(fingerd_strh, fingerd_port_index, fingerd_port);
        GetIndNumber(ports_strh_id, finger_port_index, finger_port);
        GetIndNumber(ports_strh_id, whois_port_index, whois_port);
        GetIndString(s, ports_strh_id, whois_str_index);
        whois_str := s;
        GetIndString(s, fingerd_strh, maxplansize_index);
        StringToNum(s, max_sane_handle_size);
        GetIndString(s, general_strh_id, cmd_key_index);
        cmd_key := s[1];
        GetIndString(s, general_strh_id, finger_button_index);
        finger_button_str := s;
        GetIndString(s, general_strh_id, whois_button_index);
        whois_button_str := s;
        InitDaemon;
        InitAddressInput;
    end;

{$ Term}
    procedure FinishFingers;
    begin
        FinishDaemon;
    end;

    procedure FOObject.Resize;
        var
            kind, fsize, bt, rt: integer;
            h: handle;
            r: rect;
            finfo: FontInfo;
    begin
        SetPort(window);
        GetDItem(window, fo_text_item, kind, h, r);
        r := windowPeek(window)^.port.portRect;
        InsetRect(r, -1, -1);
        SetDItem(window, fo_text_item, kind, h, r);
        textob.Resize;
    end;

    procedure FOObject.Zoom (code: integer);
        var
            lines: integer;
    begin
        if code = inZoomOut then begin
            with textob.te^^ do begin
                lines := nLines;
        {since nLines isn’t right if the last character is a return, check for that case}
                if Ptr(ORD(hText^) + teLength - 1)^ = 13 then
                    lines := lines + 1;
                zoomSize.v := lines * lineHeight + 20;
            end;
            if zoomSize.v < growRect.top then
                zoomSize.v := growRect.top;
            if zoomSize.v > growRect.bottom then
                zoomSize.v := growRect.bottom;
        end;
        inherited Zoom(code);
    end;

    procedure FOObject.DoActivateDeactivate (activate: boolean);
    begin
        textob.DoActivateDeactivate(activate);
    end;

    procedure Finger;
        var
            fio: FIObject;
    begin
        new(fio);
        fio.Create(finger_input_dialog_id);
        ShowWindow(fio.window);
    end;

    function FOObject.EditMenuEnabled: boolean;
    begin
        EditMenuEnabled := textob.EditMenuEnabled;
    end;

    procedure FOObject.SetEditMenuItem (item: integer);
    begin
        textob.SetEditMenuItem(item);
    end;

    procedure FOObject.DoEditMenu (item: integer);
    begin
        textob.DoEditMenu(item);
    end;

    function FOObject.DoMainClick (er: eventRecord): boolean;
        var
            pt: point;
    begin
        pt := er.where;
        SetPort(window);
        GlobalToLocal(pt);
        if not PtInRect(pt, textob.te^^.viewRect) then
            SetCursor(arrow);
        DoMainClick := inherited DoMainClick(er);
    end;

    procedure FOObject.DoItemWhere (er: eventRecord; item: integer);
    begin
        textob.DoItemWhere(er, item);
        if textob.te^^.selStart = textob.te^^.selEnd then begin  { kludge to make the carret go away }
            TEDeactivate(textob.te);
            TEActivate(textob.te);
        end;
    end;

    function DefObject.DoMainClick (er: eventRecord): boolean;
    begin
        SetCursor(arrow);
        DoMainClick := inherited DoMainClick(er);
    end;

    procedure DefObject.CalculateRegion (var rgn: rgnHandle);
    begin
        if fingering > 0 then
            SetCursor(GetCursor(my_waiting_cursor)^^)
        else
            SetCursor(arrow);
        rgn := nil;
    end;

    procedure FOObject.CalculateRegion (var rgn: rgnHandle);
        var
            pt: point;
            rgn2: rgnHandle;
            r: rect;
    begin
        rgn := NewRgn;

        r := textob.te^^.viewRect;
        SetPort(window);
        GetMouse(pt);
        RectRgn(rgn, r);
        if PtInRect(pt, r) then begin
            SetCursor(GetCursor(iBeamCursor)^^);
        end
        else begin
            if fingering > 0 then
                SetCursor(GetCursor(my_waiting_cursor)^^)
            else
                SetCursor(arrow);
            rgn2 := NewRgn;
            SetRectRgn(rgn2, -30000, -30000, 30000, 30000);
            DiffRgn(rgn2, rgn, rgn);
            DisposeRgn(rgn2);
        end;
    end;

    procedure DrawFingerText (dp: dialogPtr; item: integer);
    begin
        FOObject(GetWObject(dp)).textob.Draw;
    end;

    procedure InsertText (sto: TEStaticObject; h: handle);
        var
            s, t: longInt;
    begin
        s := GetHandleSize(h);
        t := GetHandleSize(sto.te^^.hText);
        SetHandleSize(sto.te^^.hText, t + s);
        if GetHandleSize(sto.te^^.hText) <> t + s then begin
            FailOutOfMemory;
        end
        else begin
            BlockMove(h^, ptr(longInt(sto.te^^.hText^) + t), s);
            TECalText(sto.te);
            sto.Adjust;
        end;
    end;

    procedure FOObject.Create (id: integer);
        var
            kind, lw: integer;
            h: handle;
            r: rect;
            temptextob: TEStaticObject;
    begin
        inherited Create(id);
        window_type := WT_FingerOutput;
        h := NewHandle(0);
        datahandle := h;
        SetPort(window);
        TextFont(monaco);
        TextSize(9);
        new(temptextob);
        textob := temptextob;
        lw := CharWidth('a') * 80;
        textob.Create(window, fo_text_item, lw, true, true, true, true);
        zoomSize.h := lw + 20;
        GetDItem(window, fo_text_item, kind, h, r);
        SetDItem(window, fo_text_item, kind, handle(@DrawFingerText), r);
        Resize;
    end;

    procedure FOObject.Destroy;
    begin
        if connection <> no_connection then begin
            AbortConnection(connection);
            SetDataPtr(connection, POINTER(-1));
        end;
        if datahandle <> nil then
            DisposHandle(datahandle);
        datahandle := nil;
        textob.Destroy;
        inherited Destroy;
    end;

    function FindPort (whois: boolean): integer;
    begin
        if whois then
            FindPort := whois_port
        else
            FindPort := finger_port;
    end;

    procedure AddIP (sh: stringHandle; ip: longInt);
        var
            s1, s2, sip: str255;
            whois: boolean;
    begin
        if prefs.showIP then begin
            UnpackName(sh^^, s1, s2, whois);
            FindString(ip, sip);
            if sip <> s2 then begin
                s2 := concat(s2, ' (', sip, ')');
                PackName(sip, s1, s2, whois);
                SetHandleSize(handle(sh), Length(sip) + 1);
                if MemError = noErr then
                    BlockMove(@sip, handle(sh)^, Length(sip) + 1);
            end;
        end;
    end;

    procedure HandleFingerTCPEvents;
        var
            oe: OSErr;
            cer: connectionEventRecord;
            s, s1, s2: str255;
            dlg: dialogPtr;
            cp: connectionIndex;
            foo: FOObject;
            texth: handle;
            remoteIP: longInt;
            defrefnum, i, ps: integer;
            whois: boolean;
            prefs_fs: FSSpec;
            prefs_rn: integer;
    begin
        for i := 1 to max_daemons do begin
            if prefs.plan_enabled and (fingerd[i] = no_connection) then begin
                oe := NewPassiveConnection(fingerd[i], fingerd_port, 0, 0, nil);
                if oe <> noErr then begin
                    FailAlert('The Finger Daemon failed to open', oe);
                    prefs.plan_enabled := false;
                    fingerd[i] := no_connection;
                end;
            end
            else if not prefs.plan_enabled and (fingerd[i] <> no_connection) then begin
                CloseConnection(fingerd[i]);
            end;
        end;
        while GetConnectionEvent(any_connection, cer) do
            with cer do begin
                case event of
                    C_Found:  begin
                        UnpackName(stringHandle(dataptr)^^, s1, s2, whois);
                        AddIP(stringHandle(dataptr), value);
                        oe := NewActiveConnection(cp, value, FindPort(whois), dataptr);
                        if oe <> noErr then begin
                            FailAlert(concat('Failed to open a connection to "', s2, '"'), oe);
                            DisposHandle(handle(dataptr));
                        end;
                    end;
                    C_SearchFailed:  begin
                        UnpackName(stringHandle(dataptr)^^, s1, s2, whois);
                        FailAlert(concat('The machine "', s2, '" doesn''t seem to exist'), 0);
                        DisposHandle(handle(dataptr));
                        fingering := fingering - 1;
                    end;
                    C_FailedToOpen:  begin
                        UnpackName(stringHandle(dataptr)^^, s1, s2, whois);
                        if timedout then
                            FailAlert(concat('The connection timed out looking for machine "', s2, '"'), 0)
                        else
                            FailAlert(concat('Machine "', s2, '" doesn''t answer'), 0);
                        DisposHandle(handle(dataptr));
                        SetDataPtr(connection, POINTER(-1));
                        fingering := fingering - 1;
                    end;
                    C_Established:  begin
                        if dataptr = nil then begin
                            for i := 1 to max_daemons do
                                if fingerd[i] = connection then
                                    fingerdata[i] := NewHandle(0);
                        end
                        else begin
                            if MemoryCritical then begin
                                FailOutOfMemory;
                                DisposHandle(handle(dataptr));
                                SetDataPtr(connection, -1);
                                CloseConnection(connection);
                                fingering := fingering - 1;
                            end
                            else begin
                                s := stringHandle(dataptr)^^;
                                DisposHandle(handle(dataptr));
                                UnpackName(s, s1, s2, whois);
                                s1 := concat(s1, chr(13), chr(10));
                                oe := TCPSend(tcpc, @s1[1], length(s1));
                                new(foo);
                                foo.Create(finger_output_dialog_id);
                                SetWTitle(foo.window, s);
                                SetDataPtr(connection, foo);
                                foo.connection := connection;
                                if prefs.showIP then begin
                                    UnpackName(s, s1, s2, whois);
                                    ps := Pos(' (', s2);
                                    if ps > 0 then begin
                                        s2 := copy(s2, 1, ps - 1);
                                        PackName(s, s1, s2, whois);
                                        UnpackName(s, s1, s2, whois);
                                    end;
                                end;
                                AddInternetCommand(s);
                            end;
                        end;
                    end;
                    C_CharsAvailable:  begin
                        if dataptr = nil then begin
                            i := 1;
                            while (i < max_daemons) and (fingerd[i] <> connection) do
                                i := i + 1;
                            if ReadChars(tcpc, fingerdata[i], value, false, true) then begin { panic! }
                                CloseConnection(connection);
                            end
                            else if StripCRLF(fingerdata[i]) then begin
{$PUSH}
{$R-}
                                s[0] := chr(GetHandleSize(fingerdata[i]));
                                BlockMove(fingerdata[i]^, @s[1], ord(s[0]));
{$POP}
                                GetPrefsFSSpec(prefs_fs);
                                prefs_rn := OpenPrefsFile(prefs_fs);
                                SendPlan(tcpc, prefs.plan_vrn, prefs.plan_dirID, prefs.plan_name, s);
                                if prefs_rn <> -1 then
                                    CloseResFile(prefs_rn);
                                CloseConnection(connection);
                            end;
                        end
                        else if dataptr <> POINTER(-1) then begin
                            if MemoryCritical then begin
                                FOObject(dataptr).Destroy;
                                FailOutOfMemory;
                                fingering := fingering - 1;
                            end
                            else if ReadChars(tcpc, FOObject(dataptr).datahandle, value, true, false) then begin
                                CloseConnection(connection);
                            end;
                        end;
                    end;
                    C_Closing:  begin
                        CloseConnection(connection);
                    end;
                    C_Closed:  begin
                        if dataptr = nil then begin
                            for i := 1 to max_daemons do
                                if fingerd[i] = connection then
                                    fingerd[i] := no_connection;
                        end
                        else if dataptr <> POINTER(-1) then begin
                            foo := FOObject(dataptr);
                            InsertText(foo.textob, foo.datahandle);
                            DisposHandle(foo.datahandle);
                            foo.datahandle := nil;
                            foo.connection := no_connection;
                            fingering := fingering - 1;
                            foo.Zoom(inZoomOut);
                            ShowWindow(foo.window);
                        end;
                    end;
                    otherwise
                        ;
                end;{case}
            end;{while with}
    end;

end.